VERSION 5.00
Begin VB.UserControl ListBoxEx 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   ClientHeight    =   450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ClipControls    =   0   'False
   ScaleHeight     =   30
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   80
   ToolboxBitmap   =   "LBoxEx.ctx":0000
End
Attribute VB_Name = "ListBoxEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'***************************************************************
Option Explicit
Public Enum LbExAppearance
    [3D]
    Flat
End Enum
Public Enum LbExMultiSelectStyle
    lbexMsNoCheck
    lbexMsFlatCheckBox
    lbexMs3DCheckBox
    lbexMsXCheck
End Enum

Event ListString(ByVal Index As Long, Text As String)
Event QuerySetSelection(ByVal Index As Long, ByVal SelState As Boolean, Cancel As Boolean, Message As String, MessageTitle As String, MessageFlags As VBA.VbMsgBoxStyle)
Attribute QuerySetSelection.VB_Description = "Called when the selection of an item  is about to change for a simple multiselect ListBox.  Set cancel to True to prevent selection.  Fill in Message parameters to show a message (don't show a message box yourself)."
Event Click(ByVal Index As Long)
Event NewTopIndex(ByVal Index As Long)
Attribute NewTopIndex.VB_Description = "Notification fired when ListBox is scrolled."
Event AfterSelectionMessage(ByVal Result As VBA.VbMsgBoxResult)
Attribute AfterSelectionMessage.VB_Description = "If QuerySetSelection is canceled and a message is shown, AfterSelectionMessage is fired with the return value from the MsgBox call."

'**Start Required**
Implements OleTypes.IHookAccelerator
Private m_IPAOHook As IPAOHook
'**End Required**

Private m_fusWinStyle As Long
Private m_hWndLB As Long
Private m_fDesign As Boolean
Private m_Appearance As LbExAppearance
Private m_CheckStyle As LbExMultiSelectStyle

Private m_SubClassLB As SubClassData
Private m_CheckWidth As Integer
Private m_FakeCaretIndex As Long

Private m_SubClassParent As SubClassData
Private m_hWndParent As Long
Private m_BlockDrawItemID As Long
Private m_fHasStrings As Boolean
Private m_fHasData As Boolean

'Cache system colors
Private Enum GDIHandles
    clrWindowText
    clrButtonShadow
    clrGrayText
    clrWindow
    clrHighlight
    clrHighlightText
    clrLastPen = clrGrayText
    clrLastBrush = clrHighlight
End Enum

Private m_Colors(0 To 5) As Long
Private m_hGDIObjects(0 To 4) As Long

Private m_IFont As IFont
Private m_iLastTopIndex As Long

Public QuickNotify As IQuickNotify

Friend Function WindowProcParent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_DRAWITEM
            With g_DerefDrawItemStruct
                .Owner.SA.pvData = lParam
                If HandleDrawItem(.pSA(0)) Then
                    WindowProcParent = 1
                    Exit Function
                End If
            End With
        Case WM_SYSCOLORCHANGE
            ResetWindowColors
        Case WM_CTLCOLORLISTBOX
            If lParam = m_hWndLB Then
                WindowProcParent = DefWindowProc(hWnd, uMsg, wParam, lParam)
                Exit Function
            End If
    End Select
'**Start Required**
    WindowProcParent = CallWindowProc(m_SubClassParent.wndprocNext, hWnd, uMsg, wParam, lParam)
    If uMsg = WM_SETFOCUS Then SetFocusAPI m_hWndLB
'**End Required**
    #If SUPPORTOLDSHELL Then
    If Not IsNewShell Then
        If uMsg = WM_PAINT Then
            If m_Appearance = [3D] Then Draw3DEdge
        End If
    End If
    #End If
End Function

Private Function HandleDrawItem(pDIS As DRAWITEMSTRUCT) As Boolean
Dim TrackRect As RECT
    If pDIS.hwndItem <> m_hWndLB Then Exit Function
    SyncFont
    If pDIS.itemID <> m_BlockDrawItemID Then
        TrackRect = pDIS.rcItem
        If m_CheckStyle Then DrawCheckBox pDIS, TrackRect, m_CheckStyle
        DrawItemText pDIS, TrackRect
        DrawFocus pDIS, TrackRect
    ElseIf pDIS.itemID = -1 Then
        TrackRect = pDIS.rcItem
        DrawItemText pDIS, TrackRect
        DrawFocus pDIS, TrackRect
    End If
    HandleDrawItem = True
End Function

#If SUPPORTOLDSHELL Then
Private Sub Draw3DEdge()
Dim TrackRect As RECT
Dim rct As RECT
    GetWindowRect m_hWndLB, rct
    With TrackRect
        .Left = 0
        .Top = 0
        .Right = .Left + rct.Right - rct.Left + 4
        .Bottom = .Top + rct.Bottom - rct.Top + 4
    End With
    DrawEdge hDC, TrackRect, EDGE_SUNKEN, BF_RECT
End Sub
#End If

Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim xPos As Integer
Dim iClickIndex As Long
Dim iCurIndex As Long
Dim iCurSel As Long
Dim fResetSel As Boolean
Static fSelectionToggled As Boolean
Static strMsg As String
Static strMsgTitle As String
Static MsgBoxFlags As VBA.VbMsgBoxStyle
'**Start Required**
    Select Case uMsg
        Case WM_SETFOCUS
            'Get in-place frame and make sure it is set to our in-between
            'implementation of IOleInPlaceActiveObject in order to catch
            'TranslateAccelerator calls
            OverrideActiveObject m_IPAOHook, Me
        Case WM_MOUSEACTIVATE
            If GetFocus <> m_hWndLB Then
                SetFocusAPI UserControl.hWnd
                WindowProc = MA_NOACTIVATE
                Exit Function
            End If
'**End Required**
        Case WM_KEYDOWN
            If vbKeySpace = LOWORD(wParam) Then
                'Use to toggle multiselected state
                If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
                    iClickIndex = CaretIndex
                    If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                    If Not iClickIndex Then GoSub ToggleSelection
                End If
            End If
        Case WM_LBUTTONDOWN
            If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
                fSelectionToggled = False
                'NT4.0, LB_ITEMFROMPOINT acts differently than Win95
                'so it can't be used here.
                iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
                If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                If Not iClickIndex Then
                    iCurIndex = CaretIndex
                    xPos = LOWORD(lParam)
                    If m_CheckStyle And xPos >= m_CheckWidth And iClickIndex <> iCurIndex Then
                        'Keep the current selected state to retoggle later.
                        iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
                        fResetSel = True
                        m_BlockDrawItemID = iClickIndex
                    Else
                        iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
                        If Not SetSelection(iClickIndex, Not CBool(iCurSel), strMsg, strMsgTitle, MsgBoxFlags) Then
                            fResetSel = True
                            m_BlockDrawItemID = iClickIndex
                        Else
                            fSelectionToggled = True
                        End If
                    End If
                End If
            End If
        Case WM_LBUTTONUP
            ShowMessage strMsg, strMsgTitle, MsgBoxFlags
            iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
            If iClickIndex >= 0 Then
                If iClickIndex <= DoMsg(LB_GETCOUNT) Then RaiseEvent Click(iClickIndex)
            End If
        Case WM_LBUTTONDBLCLK
            If m_CheckStyle And Not fSelectionToggled Then
                iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
                If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                If Not iClickIndex Then GoSub ToggleSelection
            End If
    End Select
    'It's hard to get all messages which change the topindex,
    'check every time.
    SetTopIndex DoMsg(LB_GETTOPINDEX)
'**Start Required**
    WindowProc = CallWindowProc(m_SubClassLB.wndprocNext, hWnd, uMsg, wParam, lParam)
'**End Required**
    If fResetSel Then
        m_BlockDrawItemID = -1
        DoMsg LB_SETSEL, iCurSel, iClickIndex
    End If
    Exit Function
ToggleSelection:
    iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
    If Not SetSelection(iClickIndex, Not CBool(iCurSel), strMsg, strMsgTitle, MsgBoxFlags) Then
        ShowMessage strMsg, strMsgTitle, MsgBoxFlags
    Else
        DoMsg LB_SETSEL, -(Not -iCurSel), iClickIndex
    End If
    Exit Function
    Return
End Function
'**Start Required**
Private Sub IHookAccelerator_TranslateAccelerator(lpmsg As OleTypes.MSG, hrReturnCode As Long)
'**End Required**
    'Return code defaults to S_FALSE (1)
    With lpmsg
        If .Message = WM_KEYDOWN Then
            Select Case LOWORD(lpmsg.wParam)
                Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
                    DoMsg .Message, .wParam, .lParam
                    hrReturnCode = 0
            End Select
        End If
    End With
'**Start Required**
End Sub
'**End Required**

Private Sub ShowMessage(Message As String, Title As String, Flags As VBA.VbMsgBoxStyle)
Dim Result As VBA.VbMsgBoxResult
    If Len(Message) Then
        If Len(Title) = 0 Then Title = App.Title
        Result = MsgBox(Message, Flags, Title)
        RaiseEvent AfterSelectionMessage(Result)
        Message = vbNullString
        Title = vbNullString
    End If
End Sub

Public Property Get hWnd() As Long
    hWnd = m_hWndLB
End Property

Private Function QueryForceHasFocus() As Boolean
    QueryForceHasFocus = GetFocus = UserControl.hWnd
End Function

Private Sub SetTopIndex(ByVal Index As Long)
    If Index <> m_iLastTopIndex Then
        m_iLastTopIndex = Index
        RaiseEvent NewTopIndex(Index)
    End If
End Sub

Private Function SetSelection(ByVal Index As Long, ByVal SelState As Boolean, Message As String, Title As String, Flags As VBA.VbMsgBoxStyle) As Boolean
Dim fCancel As Boolean
    If StyleBit(LBS_MULTIPLESEL) Then
        Message = vbNullString
        Title = vbNullString
        Flags = 0
        If Not QuickNotify Is Nothing Then
            QuickNotify.QuerySetSelection Index, SelState, fCancel, Message, Title, Flags
        Else
            RaiseEvent QuerySetSelection(Index, SelState, fCancel, Message, Title, Flags)
        End If
        If fCancel Then
            If Len(Message) = 0 Then Beep
        End If
        SetSelection = Not fCancel
    Else
        SetSelection = True
    End If
End Function

Private Property Get ListString(ByVal Index As Long) As String
Attribute ListString.VB_Description = "Called when an item is drawn if the StoreStrings property is False."
    If m_fHasStrings Then
        ListString = String$(DoMsg(LB_GETTEXTLEN, Index), 0)
        DoMsgString LB_GETTEXT, Index, ListString
    ElseIf Not QuickNotify Is Nothing Then
        QuickNotify.ListString Index, ListString
    Else
        RaiseEvent ListString(Index, ListString)
    End If
End Property

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If m_fDesign Then
        If PropertyName = "DisplayName" Then UserControl.Refresh
    End If
End Sub

Private Sub UserControl_Initialize()
'**Start Required**
    InitializeIPAOHook m_IPAOHook, Me
'**End Required**
    ResetWindowColors
    m_BlockDrawItemID = -1
    m_FakeCaretIndex = -1
    m_fusWinStyle = WS_VSCROLL Or WS_HSCROLL Or WS_CHILD Or WS_CLIPSIBLINGS Or LBS_NOTIFY
End Sub

Private Sub UserControl_InitProperties()
    m_Appearance = [3D]
    StyleBit(LBS_HASSTRINGS) = True
    InitializeMode
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Appearance = PropBag.ReadProperty("Appearance", [3D])
    StyleBit(LBS_NOINTEGRALHEIGHT) = Not PropBag.ReadProperty("IntegralHeight", False)
    SetMultiSelect PropBag.ReadProperty("MultiSelect", vbMultiSelectNone)
    m_CheckStyle = PropBag.ReadProperty("MultiSelectStyle", lbexMsNoCheck)
    StyleBit(LBS_NODATA) = Not PropBag.ReadProperty("StoreData", True)
    StyleBit(LBS_HASSTRINGS) = PropBag.ReadProperty("StoreStrings", True)
    StyleBit(LBS_SORT) = PropBag.ReadProperty("Sorted", False)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    InitializeMode
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Appearance", m_Appearance
    PropBag.WriteProperty "IntegralHeight", Not StyleBit(LBS_NOINTEGRALHEIGHT)
    PropBag.WriteProperty "StoreData", Not StyleBit(LBS_NODATA)
    PropBag.WriteProperty "StoreStrings", StyleBit(LBS_HASSTRINGS)
    PropBag.WriteProperty "Sorted", StyleBit(LBS_SORT)
    PropBag.WriteProperty "MultiSelect", MultiSelect
    PropBag.WriteProperty "MultiSelectStyle", m_CheckStyle
    PropBag.WriteProperty "Font", UserControl.Font, Ambient.Font
End Sub

Private Sub UserControl_Terminate()
    If Not m_fDesign Then
        'WARNING: If you put a breakpoint after the UnSubClass calls,
        'then you must not expand the Me value in the locals window.
        'This attempts to evaluate all public property procedures, some
        'of which rely on a current subclass.
        If m_hWndParent Then UnSubClass m_SubClassParent, m_hWndParent
        If m_hWndLB Then UnSubClass m_SubClassLB, m_hWndLB
        m_hWndParent = 0
        m_hWndLB = 0
        ResetWindowColors True 'Free GDI objects
    End If
End Sub

Private Sub UserControl_Paint()
Dim rct As RECT
    If m_fDesign Then
        With UserControl
            If m_Appearance = [3D] Then
                GetClientRect .hWnd, rct
                DrawEdge .hDC, rct, EDGE_SUNKEN, BF_RECT
                .CurrentX = 4
                .CurrentY = 2
            Else
                Rectangle .hDC, 0, 0, .ScaleWidth, .ScaleHeight
                .CurrentX = 3
                .CurrentY = 1
            End If
            UserControl.Print .Ambient.DisplayName
        End With
    End If
End Sub

Private Sub UserControl_Resize()
Dim Shift As Integer
Static fResizing As Boolean
Dim rctLB As RECT
Dim rctCtrl As RECT
Dim hWnd As Long
    If fResizing Then Exit Sub
    If m_hWndLB Then
        #If SUPPORTOLDSHELL Then
        If Not IsNewShell And m_Appearance = [3D] Then Shift = 2
        #End If
        SetWindowPos m_hWndLB, 0, Shift, Shift, ScaleWidth - 2 * Shift, ScaleHeight - 2 * Shift, SWP_NOZORDER Or SWP_NOACTIVATE
        If Not StyleBit(LBS_NOINTEGRALHEIGHT) Then
            hWnd = UserControl.hWnd
            fResizing = True
            GetWindowRect m_hWndLB, rctLB
            GetWindowRect hWnd, rctCtrl
            SetWindowPos hWnd, 0, 0, 0, rctCtrl.Right - rctCtrl.Left, rctLB.Bottom - rctLB.Top + 2 * Shift, SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_NOMOVE
            fResizing = False
        End If
    End If
End Sub

Public Property Get Appearance() As LbExAppearance
    Appearance = m_Appearance
End Property
Public Property Let Appearance(ByVal New_Appearance As LbExAppearance)
    If m_fDesign Then
        If m_Appearance <> New_Appearance Then
            If New_Appearance < [3D] Or New_Appearance > Flat Then Err.Raise 5
            m_Appearance = New_Appearance
            UserControl.Refresh
        End If
    Else
        Err.Raise 382
    End If
End Property

Private Sub DrawCheckBox(pDIS As DRAWITEMSTRUCT, prc As RECT, CheckStyle As LbExMultiSelectStyle)
Dim hBrushOld As Long, hPenOld As Long
Dim pLogBrush As LOGBRUSH
Dim hDC As Long
Dim rct As RECT
    If pDIS.itemAction And (ODA_SELECT Or ODA_DRAWENTIRE) Then
        #If SUPPORTOLDSHELL Then
        If Not IsNewShell Or CheckStyle = lbexMsXCheck Then
        #Else
        If CheckStyle = lbexMsXCheck Then
        #End If
            hDC = pDIS.hDC
            SetBkColor hDC, m_Colors(clrWindow)
            '??? Use SysColorBrush
            hPenOld = SelectObject(hDC, GDIObjects(clrWindowText))
            hBrushOld = SelectObject(hDC, GDIObjects(clrWindow))
            With prc
                'Ignore error checking, it isn't worth it.
                Rectangle hDC, .Left + 2, _
                               .Top + 2, _
                               .Left + 3 + (.Bottom - .Top - 5), _
                               .Bottom - 2
                If pDIS.itemState And ODS_SELECTED Then
                    MoveToEx hDC, .Left + 2, .Top + 2, ByVal 0
                    LineTo hDC, .Left + 2 + (.Bottom - .Top - 5), .Bottom - 3
                    MoveToEx hDC, .Left + 2 + (.Bottom - .Top - 5), .Top + 2, ByVal 0
                    LineTo hDC, .Left + 2, .Bottom - 3
                End If
            End With
            'Clean up hDC
            SelectObject hDC, hPenOld
            SelectObject hDC, hBrushOld
        Else
            hDC = pDIS.hDC
            rct = prc
            rct.Right = rct.Left + prc.Bottom - prc.Top
            If CheckStyle = lbexMs3DCheckBox Then
                DrawFrameControl pDIS.hDC, rct, DFC_BUTTON, _
                     DFCS_BUTTONCHECK - CBool(pDIS.itemState And ODS_SELECTED) * DFCS_CHECKED
            Else
                rct = prc
                rct.Right = rct.Left + prc.Bottom - prc.Top
                If pDIS.itemState And ODS_SELECTED Then DrawFrameControl hDC, rct, 2, 1
                With rct
                    .Left = prc.Left + 1
                    .Right = .Left + 1 + (prc.Bottom - prc.Top - 4)
                    .Top = prc.Top + 1
                    .Bottom = prc.Bottom - 2
                    hPenOld = SelectObject(hDC, GDIObjects(clrButtonShadow))
                    If pDIS.itemState And ODS_SELECTED Then
                        MoveToEx pDIS.hDC, .Left, .Top, ByVal 0&
                        'UNDONE: polygon this?
                        LineTo hDC, .Right, .Top
                        LineTo hDC, .Right, .Bottom
                        LineTo hDC, .Left, .Bottom
                        LineTo hDC, .Left, .Top
                    Else
                        Rectangle hDC, .Left, .Top, .Right + 1, .Bottom + 1
                    End If
                    SelectObject hDC, hPenOld
                End With
            End If
        End If
    End If
    With prc
        .Left = .Left + .Bottom - .Top
    End With
End Sub

Private Function DrawItemText(pDIS As DRAWITEMSTRUCT, prc As RECT)
Dim hBrushOld As Long, hPenOld As Long
Dim clrText As GDIHandles, clrBack As GDIHandles
Dim hDC As Long
Dim strItem As String, cbItem As Integer
    hDC = pDIS.hDC
    If CBool(m_CheckStyle) And pDIS.itemAction And ODA_SELECT Then
        DrawItemText = True
        Exit Function
    Else
        'This could all be done with less code, but more API calls.
        'Until we can short circuit, use this approach. (CaretIndex is an API call).
        If pDIS.itemID = -1 Then
            clrBack = clrWindow
            clrText = clrWindowText
        Else
            If m_CheckStyle Then
                If pDIS.itemState And ODS_FOCUS Then
                    clrBack = clrHighlight
                    clrText = clrHighlightText
                ElseIf HasFocus Then
                    clrBack = clrWindow
                    clrText = clrWindowText
                Else
                    If pDIS.itemID = CaretIndex Then
                        clrBack = clrHighlight
                        clrText = clrHighlightText
                    Else
                        clrBack = clrWindow
                        clrText = clrWindowText
                    End If
                End If
            Else
                If pDIS.itemState And ODS_SELECTED Then
                    clrBack = clrHighlight
                    clrText = clrHighlightText
                Else
                    clrBack = clrWindow
                    clrText = clrWindowText
                End If
            End If
        End If
        SetTextColor hDC, m_Colors(clrText)
        SetBkColor hDC, m_Colors(clrBack)
        hBrushOld = SelectObject(hDC, GDIObjects(clrBack))
        hPenOld = SelectObject(hDC, GetStockObject(NULL_PEN))
        With prc
            Rectangle hDC, .Left, .Top, .Right + 1, .Bottom + 1
        End With
        'Clean up hDC
        SelectObject hDC, hBrushOld
        SelectObject hDC, hPenOld
    End If
    If Not pDIS.itemID Then
        If Not pDIS.itemID Then
            strItem = ListString(pDIS.itemID)
        End If
        If StrPtr(strItem) Then
            With prc
                .Left = .Left + 1
                DrawItemText = DrawText(hDC, strItem, -1, prc, _
                        DT_VCENTER Or DT_LEFT Or DT_SINGLELINE Or DT_NOPREFIX Or DT_NOCLIP)
                .Left = .Left - 1
            End With
        End If
    End If
End Function

Private Function DrawFocus(pDIS As DRAWITEMSTRUCT, prc As RECT) As Boolean
    If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        If pDIS.itemState And ODS_FOCUS Then
            If HasFocus Then
                DrawFocusRect pDIS.hDC, prc
            ElseIf QueryForceHasFocus Then
                DrawFocusRect pDIS.hDC, prc
            End If
        End If
    End If
    DrawFocus = True
End Function

Public Sub Clear()
    DoMsg LB_RESETCONTENT
    DoMsg LB_SETHORIZONTALEXTENT, 0, 0
    m_iLastTopIndex = -1
End Sub

Public Property Let ListCount(ByVal New_ListCount As Long)
Dim l&
    If m_fHasData Then
        If m_fHasStrings Then
            Err.Raise 5, , "StoreStrings must be False"
        Else
            Clear
            For l& = 1 To New_ListCount
                DoMsg LB_ADDSTRING
            Next
        End If
    Else
        DoMsg LB_SETCOUNT, New_ListCount
    End If
End Property
Public Property Get ListCount() As Long
    NoPropertySheet
    ListCount = DoMsg(LB_GETCOUNT)
End Property
Public Function AddItem(NewItem As String, Optional ByVal Index As Long = -1) As Long
    If m_fHasStrings Then
        If StrPtr(NewItem) = 0 Then NewItem = ""
        If Not Index Then
            AddItem = DoMsgString(LB_ADDSTRING, 0, NewItem)
        Else
            AddItem = DoMsgString(LB_INSERTSTRING, Index, NewItem)
        End If
    ElseIf m_fHasData Then
        If Not Index Then
            AddItem = DoMsg(LB_ADDSTRING)
        Else
            AddItem = DoMsg(LB_INSERTSTRING, Index)
        End If
    Else
        Err.Raise 5, , "StoreStrings or StoreData must be True"
    End If
End Function
Public Sub RemoveItem(ByVal Index As Long)
    DoMsg LB_DELETESTRING, Index
End Sub
Public Property Get List(ByVal Index As Long) As String
    NoPropertySheet
    List = ListString(Index)
End Property
Public Property Get ItemData(ByVal Index As Long) As Long
    If m_fHasData Then
        ItemData = DoMsg(LB_GETITEMDATA, Index, 0)
    Else
        Err.Raise 5, , "Not supported when StoreData property is False"
    End If
End Property

Public Property Let ItemData(ByVal Index As Long, ByVal Value As Long)
    If m_fHasData Then
        DoMsg LB_SETITEMDATA, Index, Value
    Else
        Err.Raise 5, , "Not supported when StoreData property is False"
    End If
End Property

Public Property Get ListIndex() As Long
    NoPropertySheet
    If DoMsg(LB_GETCOUNT) Then
        ListIndex = CaretIndex
    Else
        ListIndex = -1
    End If
End Property
Public Property Let ListIndex(ByVal New_ListIndex As Long)
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        WindowProc m_hWndLB, LB_SETCARETINDEX, New_ListIndex, 0
    Else
        WindowProc m_hWndLB, LB_SETCURSEL, New_ListIndex, 0
    End If
End Property

Public Property Get TopIndex() As Long
    NoPropertySheet
    If DoMsg(LB_GETCOUNT) Then
        TopIndex = m_iLastTopIndex
    Else
        TopIndex = -1
    End If
End Property
Public Property Let TopIndex(ByVal New_TopIndex As Long)
    WindowProc m_hWndLB, LB_SETTOPINDEX, New_TopIndex, 0
End Property

Public Property Get Selected(ByVal Index As Long) As Boolean
    NoPropertySheet
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        Selected = DoMsg(LB_GETSEL, Index)
    Else
        Err.Raise 5, , "Only applies to MultiSelect listbox."
    End If
End Property
Public Property Let Selected(ByVal Index As Long, ByVal New_Selected As Boolean)
Dim strMsg As String, strMsgTitle As String, MsgBoxFlags As VbMsgBoxStyle
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        If SetSelection(Index, New_Selected, strMsg, strMsgTitle, MsgBoxFlags) Then
            DoMsg LB_SETSEL, -New_Selected, Index
        Else
            ShowMessage strMsg, strMsgTitle, MsgBoxFlags
        End If
    Else
        Err.Raise 5, , "Only applies to MultiSelect listbox."
    End If
End Property

Private Property Get GDIObjects(ByVal hGDI As GDIHandles) As Long
Dim pLogBrush As LOGBRUSH
    If m_hGDIObjects(hGDI) = 0 Then
        Select Case hGDI
            Case Is <= clrLastPen
                m_hGDIObjects(hGDI) = CreatePen(PS_SOLID, 1, m_Colors(hGDI))
            Case Is <= clrLastBrush
                With pLogBrush
                    .lbStyle = BS_SOLID
                    .lbColor = m_Colors(hGDI)
                End With
                m_hGDIObjects(hGDI) = CreateBrushIndirect(pLogBrush)
        End Select
    End If
    GDIObjects = m_hGDIObjects(hGDI)
End Property

Private Function ResetWindowColors(Optional fClearOnly As Boolean = False)
Dim i%
    For i% = 0 To 3
        If m_hGDIObjects(i%) Then DeleteObject m_hGDIObjects(i%)
        m_hGDIObjects(i%) = 0
    Next i%
    If Not fClearOnly Then
        m_Colors(clrWindow) = GetSysColor(COLOR_WINDOW)
        m_Colors(clrWindowText) = GetSysColor(COLOR_WINDOWTEXT)
        m_Colors(clrHighlight) = GetSysColor(COLOR_HIGHLIGHT)
        m_Colors(clrHighlightText) = GetSysColor(COLOR_HIGHLIGHTTEXT)
        m_Colors(clrButtonShadow) = GetSysColor(COLOR_BTNSHADOW)
        m_Colors(clrGrayText) = GetSysColor(COLOR_BTNFACE)
    End If
End Function

Private Property Get HasFocus() As Boolean
    HasFocus = m_hWndLB = GetFocus
End Property

Private Property Get CaretIndex() As Long
'LB_SETCARETINDEX causes the listbox to draw, which calls
'LB_GETCARETINDEX, which is wrong until the SETCARETINDEX
'message has finished.
    If Not m_FakeCaretIndex Then
        CaretIndex = m_FakeCaretIndex
    Else
        CaretIndex = DoMsg(LB_GETCARETINDEX, 0, 0)
    End If
End Property

Private Function DoMsg(ByVal uMsg As Long, Optional ByVal wParam As Long = 0, Optional ByVal lParam As Long = 0) As Long
    DoMsg = CallWindowProc(m_SubClassLB.wndprocNext, m_hWndLB, uMsg, wParam, lParam)
End Function

Private Function DoMsgString(ByVal uMsg As Long, ByVal wParam As Long, lParam As String) As Long
    DoMsgString = CallWindowProcAny(m_SubClassLB.wndprocNext, m_hWndLB, uMsg, wParam, ByVal lParam)
End Function

Private Sub InvalidateItemRect(ByVal Index As Long)
Dim rct As RECT
    CallWindowProc m_SubClassLB.wndprocNext, m_hWndLB, LB_GETITEMRECT, Index, VarPtr(rct)
    InvalidateRect m_hWndLB, rct, 1
End Sub

Private Sub NoPropertySheet()
    'To keep a property out of both the locals window and the
    'property sheet, check the 'Don't show in Property Browser'
    'attribute, available on the Advanced tab of the Tools/Procedure
    'Attributes dialog.  To stop the item from showing in the
    'property sheet, but still support it in the locals window,
    'use this approach.
    
    'If you stop on this error, then right click on the
    'code pane and choose Toggle/Break on Unhandled Errors.
    'You can set the default for this setting in the Tools/Options
    'dialog on the General tab.
    If m_fDesign Then Err.Raise 394 'GetNotSupported
End Sub

Private Sub DesignTimeOnly()
    If Not m_fDesign Then Err.Raise 382
End Sub

Private Sub SetDesignMode()
    On Error Resume Next
    m_fDesign = Not Ambient.UserMode
    If Err Then m_fDesign = True
    On Error GoTo 0
End Sub

Private Function SyncFont() As Boolean
Dim tmpIFont As IFont
    If Not m_IFont Is Nothing Then
        Set tmpIFont = UserControl.Font
        If m_IFont.hFont <> tmpIFont.hFont Then
            'This cuts off outside objects from accessing
            'the current font object
            m_IFont.Clone tmpIFont
            Set Me.Font = tmpIFont
            Set m_IFont = Nothing
        End If
    End If
End Function

Public Property Get Font() As Font
Dim tmpIFont As IFont
    If m_fDesign Then
        Set Font = UserControl.Font
    Else
        If m_IFont Is Nothing Then
            Set tmpIFont = UserControl.Font
            tmpIFont.Clone m_IFont
        End If
        Set Font = m_IFont
    End If
End Property

Public Property Set Font(ByVal New_Font As Font)
Dim IFont As IFont
Dim tmpFont As Font
    If m_fDesign Then
        Set UserControl.Font = New_Font
    Else
        With UserControl
            'We want to keep the old font temporarily since windows is still
            'holding a handle to it in the listbox
            Set tmpFont = .Font
            Set .Font = New_Font 'This will raise an error if New_Font is nothing
            If m_hWndLB Then
                Set IFont = New_Font
                DoMsg WM_SETFONT, IFont.hFont, 1&
                m_CheckWidth = .TextHeight("A")
                DoMsg LB_SETITEMHEIGHT, 0, m_CheckWidth
            End If
        End With
    End If
    PropertyChanged "Font"
End Property

Public Sub Refresh()
    UserControl.Refresh
End Sub

Private Sub InitializeMode()
Dim IFont As IFont
Dim Shift As Integer
Dim dwExStyle As Long
Dim Style As Long
    SetDesignMode
    If Not m_fDesign Then
        If m_hWndLB Then Exit Sub
        Style = m_fusWinStyle
        If m_Appearance = [3D] Then
            #If SUPPORTOLDSHELL Then
            If Not IsNewShell Then Shift = 2
            #End If
            dwExStyle = WS_EX_CLIENTEDGE
        Else
            Style = Style Or WS_BORDER
        End If
        m_fHasStrings = Style And LBS_HASSTRINGS
        m_fHasData = Not Style And LBS_NODATA
        If Not m_fHasData Or Not m_fHasStrings Or m_CheckStyle Then Style = Style Or LBS_OWNERDRAWFIXED
        With UserControl
            m_hWndLB = CreateWindowEx(dwExStyle, "LISTBOX", vbNullString, _
                       Style, Shift, Shift, .ScaleWidth - 2 * Shift, .ScaleHeight - 2 * Shift, .hWnd, 0, App.hInstance, ByVal 0&)
            If m_hWndLB Then
                Set IFont = .Font
                SendMessage m_hWndLB, WM_SETFONT, IFont.hFont, ByVal 1&
                m_CheckWidth = .TextHeight("A")
                SendMessage m_hWndLB, LB_SETITEMHEIGHT, 0, ByVal m_CheckWidth
                m_iLastTopIndex = -1
                SubClass m_SubClassLB, m_hWndLB, ObjPtr(Me), AddressOf RedirectLBProc
                m_hWndParent = GetParent(m_hWndLB)
                SubClass m_SubClassParent, m_hWndParent, ObjPtr(Me), AddressOf RedirectLBProcParent
                ShowWindow m_hWndLB, SW_SHOW
            End If
        End With
    End If
End Sub

Public Property Get Sorted() As Boolean
    Sorted = StyleBit(LBS_SORT)
End Property
Public Property Let Sorted(ByVal New_Sorted As Boolean)
    DesignTimeOnly
    PropertyChanged "Sorted"
    StyleBit(LBS_SORT) = New_Sorted
End Property

Public Property Get StoreStrings() As Boolean
    StoreStrings = StyleBit(LBS_HASSTRINGS)
End Property
Public Property Let StoreStrings(ByVal New_StoreStrings As Boolean)
    DesignTimeOnly
    PropertyChanged "StoreStrings"
    StyleBit(LBS_HASSTRINGS) = New_StoreStrings
    If Not New_StoreStrings And Sorted Then
        Sorted = False
    End If
    If New_StoreStrings And Not StoreData Then
        StoreData = True
    End If
End Property

Public Property Get StoreData() As Boolean
    StoreData = Not StyleBit(LBS_NODATA)
End Property
Public Property Let StoreData(ByVal New_StoreData As Boolean)
    DesignTimeOnly
    PropertyChanged "StoreData"
    StyleBit(LBS_NODATA) = Not New_StoreData
    If Not New_StoreData And StoreStrings Then
        StoreStrings = False
    End If
End Property

Public Property Get IntegralHeight() As Boolean
    IntegralHeight = Not StyleBit(LBS_NOINTEGRALHEIGHT)
End Property

Public Property Let IntegralHeight(ByVal RHS As Boolean)
    DesignTimeOnly
    PropertyChanged "IntegralHeight"
    StyleBit(LBS_NOINTEGRALHEIGHT) = Not RHS
End Property
Public Property Get MultiSelect() As MultiSelectConstants
    Select Case m_fusWinStyle And (LBS_MULTIPLESEL Or LBS_EXTENDEDSEL)
        Case LBS_MULTIPLESEL
            MultiSelect = vbMultiSelectSimple
        Case LBS_EXTENDEDSEL
            MultiSelect = vbMultiSelectExtended
        Case Else
            MultiSelect = vbMultiSelectNone
    End Select
End Property

Public Property Let MultiSelect(ByVal RHS As MultiSelectConstants)
    DesignTimeOnly
    PropertyChanged "MultiSelect"
    SetMultiSelect RHS
End Property
Private Sub SetMultiSelect(ByVal RHS As MultiSelectConstants)
    Select Case RHS
        Case vbMultiSelectSimple
            StyleBit(LBS_MULTIPLESEL) = True
            StyleBit(LBS_EXTENDEDSEL) = False
        Case vbMultiSelectExtended
            StyleBit(LBS_MULTIPLESEL) = False
            StyleBit(LBS_EXTENDEDSEL) = True
        Case vbMultiSelectNone
            StyleBit(LBS_MULTIPLESEL) = False
            StyleBit(LBS_EXTENDEDSEL) = False
            If m_CheckStyle Then MultiSelectStyle = lbexMsNoCheck
    End Select
End Sub
Public Property Get MultiSelectStyle() As LbExMultiSelectStyle
    MultiSelectStyle = m_CheckStyle
End Property
Public Property Let MultiSelectStyle(ByVal RHS As LbExMultiSelectStyle)
    If RHS < lbexMsNoCheck Or RHS > lbexMsXCheck Then Err.Raise 5
    If Not m_fDesign Then
        If 0 = (GetWindowLong(m_hWndLB, GWL_STYLE) And LBS_OWNERDRAWFIXED) Then
            Err.Raise 5, , "StoreStrings must be False to change MultiSelectStyle at runtime"
        End If
        m_CheckStyle = RHS
        UserControl.Refresh
    Else
        PropertyChanged "MultiSelectStyle"
        m_CheckStyle = RHS
    End If
End Property
Private Property Let StyleBit(ByVal Bit As Long, ByVal RHS As Boolean)
    If RHS Then
        m_fusWinStyle = m_fusWinStyle Or Bit
    Else
        m_fusWinStyle = Not (m_fusWinStyle Imp Bit)
    End If
End Property
Private Property Get StyleBit(ByVal Bit As Long) As Boolean
    StyleBit = m_fusWinStyle And Bit
End Property

